home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / env / shadow.scm < prev    next >
Text File  |  1995-10-13  |  2KB  |  71 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; Deal with shadowed variables.
  5.  
  6. ; When a variable is shadowed by a variable, split the existing shared
  7. ; location into two replacement locations.
  8.  
  9. ; name (structure-ref p name) (define name ...) within a single template
  10. ; will lose big.
  11.  
  12. ;(define *replaced-locations* '()) ;alist of (old rep ((uid ...) . new))
  13.  
  14. (define (shadow-location! old p-uids new replacement)
  15.   (if (location-defined? old)
  16.       (set-contents! replacement (contents old)))
  17.   (set-location-id! old
  18.             (vector replacement p-uids new))
  19.   (set-location-defined?! old #f))  ;so that exceptions will be raised
  20.  
  21. (define maybe-replace-location
  22.   (let ((memv memv))
  23.     (lambda (loc p-uid)            ;Package's unique id
  24.       (let ((foo (location-id loc)))
  25.     (if (vector? foo)
  26.         (maybe-replace-location
  27.          (if (memv p-uid (vector-ref foo 1))
  28.          (vector-ref foo 2)
  29.          (vector-ref foo 0))
  30.          p-uid)
  31.         loc)))))
  32.  
  33. ; Exception handler:
  34.  
  35. (define (deal-with-replaced-variables succeed)
  36.   (lambda (opcode args)
  37.     (primitive-catch
  38.      (lambda (cont)
  39.        (let* ((loc (car args))
  40.           (tem (continuation-template cont))
  41.           (index (code-vector-ref (template-code tem)
  42.                       (- (continuation-pc cont) 1))))
  43.      (if (eq? (template-ref tem index) loc)
  44.          (let* ((p-uid (do ((env (continuation-env cont)
  45.                      (vector-ref env 0)))
  46.                    ((not (vector? env)) env)))
  47.             (new (maybe-replace-location loc p-uid)))
  48.            (if (eq? new loc)
  49.            (signal-exception opcode args)
  50.            (begin (template-set! tem index new)
  51.               (signal 'note "Replaced location" loc new p-uid)
  52.               (if (location-defined? new)
  53.                   (succeed new (cdr args))
  54.                   (signal-exception opcode
  55.                         (cons new (cdr args)))))))
  56.          (error "lossage in deal-with-replaced-variables"
  57.             loc index)))))))
  58.  
  59. (let ((op/global (enum op global))
  60.       (op/set-global! (enum op set-global!)))
  61.  
  62.   (define-exception-handler op/global
  63.     (deal-with-replaced-variables
  64.        (lambda (loc more-args)
  65.      (contents loc))))
  66.  
  67.   (define-exception-handler op/set-global!
  68.     (deal-with-replaced-variables
  69.        (lambda (loc more-args)
  70.      (set-contents! loc (car more-args))))))
  71.